home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Float source / fltMem < prev    next >
Text File  |  1990-12-22  |  8KB  |  243 lines
  1. \ Memory manager for floating point heap
  2. \  9/01/85  cbd Version 1.0
  3. \  9/24/87  rfl fixed f2dup
  4.  
  5. \ The floating heap is a region of heap that is divided into 12-byte
  6. \ blocks.  Each block consists of two bytes of status information, along
  7. \ with 10 bytes of data. If the 0 bit of the status field is on, the block
  8. \ is in use. Otherwise, the status field holds the offset of the next
  9. \ free block from the start of the array, and the 0 bit is off because
  10. \ the offset must be even.
  11.  
  12. \ execWord provides an interface from code to a high-level word.
  13. \ If the word completes, it will return to the point in the last
  14. \ high-level word that was executed before the code was invoked.
  15. \ the contents of D0 and D1 are placed on the stack, and the offset
  16. \ of the executed word must be in D7. It can't have named parms.
  17. :CODE execWord
  18.         move.l  a4,-(a7)        ; save old IP on the return stack  
  19.         lea     0(a3,d7.l),a4   ; set up the IP
  20.         move.l  d0,-(a7)        ; push parameters and do a NEXT
  21.         move.l  d1,-(a7)
  22. ;CODE        
  23.  
  24. \ floating-point error handler
  25. : fpErr  SELECT{
  26.     0   IS{ type }END       \ print msg and return to caller 
  27.     1   IS{ cr ." Floating point heap is full." abort }END
  28.     2   IS{ cr ." Not a Float:" . abort }END
  29.     3   IS{ cr ." Uninitialized float argument"  abort }END
  30.     Default{  cr ." Undefined floating point error code" abort
  31.     }SELECT    ;
  32.  
  33. \ Code-based NEW: method for speed
  34. :CODE  fltNew
  35.         move.l  d5,a2           ; get mstack
  36.         movea.l  (A2),a0        ; get obj addr
  37.         adda.l   a3,a0          ; a0 = absolute addr
  38.         clr.l   d7
  39.         move.w  0(a0),d7        ; d7 = offset of first free block
  40.         beq     fullErr
  41.         move.w  0(a0,d7.l),d0     ; d0 = addr of next free block
  42.         move.w  d0,0(a0)        ; Put in free head ptr
  43.         move.w  #1,0(a0,d7.l)     ; mark in use
  44.         add.l   (a2),d7         ; get rel addr of the block
  45.         move.l  d7,-(A7)
  46.         move.l  (a4)+,d6        ; next
  47.         move.l  0(a3,d6.l),d7
  48.         jmp     0(a3,d7.l)
  49. fullErr move.l  #1,d1           ; code for err handler
  50.         move.l  YERK[fpErr],d7
  51.         move.l  YERK[execWord],d6
  52.         jmp     0(a3,d6.l)
  53. ;CODE
  54.  
  55. \ return a float block to the free list - code method
  56. :CODE  fltDisp
  57.         move.l  (A7)+,a1        ; a0 = flt rel addr
  58.         adda.l  a3,a1           ; absolute
  59.         move.l  d5,a2           ; get mstack
  60.         move.l  (a2),a0         ; get receiver
  61.         adda.l  a3,a0           ; absolute receiver addr
  62.         move.w  (a0),d7         ; next free block offset
  63.         move.w  d7,(a1)         ; store link in free block
  64.         sub.l   a0,a1           ; get offs of free block
  65.         move.w  a1,(a0)         ; store in free head ptr        
  66. ;CODE        
  67.  
  68. \ because of assumptions made by code-based methods, this
  69. \ class CANNOT be used to create instance variables.
  70. :CLASS fltHeap  <Super Object  12 <Indexed
  71.  
  72.     Int FreeHead        \ offset of first free block 
  73.  
  74. \ set all blocks to free and link together.
  75.  :M INIT:  limit 1- 0 
  76.      DO  I 1+ (^elem) copyM - I (^elem) w!  LOOP
  77.      0 limit 1- (^elem) w!  0 (^elem) copym - put: freeHead  ;M
  78.  
  79. \ ( -- fPtr ) return a ptr to a new block  
  80.  :M NEW:  fltNew   ;M
  81.  
  82. \  return # of float blocks remaining in float heap
  83.  :M ROOM: { \ offs #free -- #free } get: freeHead  -> offs 0 -> #free
  84.       BEGIN  
  85.         offs 0> offs 1 and not and 
  86.       WHILE   offs copyM + w@ -> offs  1 ++> #free 
  87.       REPEAT  #free ;M
  88.  
  89. \ ( fptr -- )  dispose of block for fptr
  90.  :M DISPOSE:  fltDisp  ;M
  91.  
  92. ;CLASS
  93.  
  94. 100 fltHeap fltMem
  95. init: fltMem
  96.  
  97. \ subroutine returns new float block ptr in d1
  98. \ destroys A0 
  99. :CODE (fltNew)
  100.         move.l  YERK[fltMem],a0
  101.         add.l   a3,a0
  102.         clr.l   d1
  103.         move.w  (a0),d1             ; d1 = offset of first free block
  104.         beq     fullErr1
  105.         move.w  0(a0,d1.l),(a0)     ; store new free head ptr
  106.         move.w  #1,0(a0,d1.l)       ; mark in use
  107.         suba.l   a3,a0              ; relative again
  108.         add.l   a0,d1               ; get rel addr of the block
  109.         rts
  110. fullerr1  move.l  #1,d1             ; code for err handler
  111.         move.l  YERK[fpErr],d7
  112.         move.l  YERK[execWord],d6
  113.         jmp     0(a3,d6.l)
  114. ;CODE
  115.  
  116. \ dispose of the float in D0 - subroutine. Destroys A0,A1, clears D0
  117. :CODE  (fltDisp)
  118.         move.l  d0,a1
  119.         beq     noFloat
  120.         andi.l  #4278190081,d0  ; $FF000001 range check
  121.         bne     noFloat         ; value is not a float
  122.         adda.l  a3,a1           ; absolute addr of float
  123.         move.l  YERK[fltMem],a0  
  124.         add.l   a3,a0      
  125.         move.w  (a0),(a1)       ; next free block offset
  126.         sub.l   a0,a1           ; get offs of free block
  127.         move.w  a1,(a0)         ; store in free head ptr 
  128.         rts 
  129. noFloat move.l  #2,d1           ; code for err handler
  130.         move.l  a1,d0           ; value of offending number
  131.         move.l  YERK[fpErr],d7
  132.         move.l  YERK[execWord],d6
  133.         jmp     0(a3,d6.l)
  134.      
  135. ;CODE
  136.  
  137. \ subroutine disposes of floats in d0,d1
  138. \ destroys A0, A1 
  139. :CODE  (fltDisp2)
  140.         move.l  d0,a1
  141.         beq     noFloat1
  142.         andi.l  #4278190081,d0  ; $FF000001 range check
  143.         bne     noFloat1         ; value is not a float
  144.         adda.l  a3,a1           ; absolute
  145.         move.l  YERK[fltMem],a0  ; a0 = float heap ptr
  146.         adda.l  a3,a0           ; absolute 
  147.         move.w  (a0),(a1)       ; next free block offset
  148.         sub.l   a0,a1           ; get offs of free block
  149.         move.w  a1,d0           ; save 
  150.         move.l  d1,a1           ; now do the other one
  151.         beq     noFloat1
  152.         andi.l  #4278190081,d1  ; $FF000001 range check
  153.         bne     noFloat1         ; value is not a float
  154.         adda.l  a3,a1           ; absolute
  155.         move.w  d0,(a1)         ; next free block offset
  156.         sub.l   a0,a1           ; get offs of free block
  157.         move.w  a1,(a0)         ; store in free head ptr 
  158.         rts       
  159. noFloat1 move.l  #2,d1           ; code for err handler
  160.         move.l  a1,d0           ; value of offending number
  161.         move.l  YERK[fpErr],d7
  162.         move.l  YERK[execWord],d6
  163.         jmp     0(a3,d6.l)
  164. ;CODE
  165.  
  166. :CODE fLit
  167.         move.l  YERK[(fltNew)],d7  
  168.         jsr     0(a3,d7.l)        ; get new float in d1
  169.         move.l  (a4)+,2(a3,d1.l)  ; move float data at IP to new block
  170.         move.l  (a4)+,6(a3,d1.l)
  171.         move.w  (a4)+,10(a3,d1.l) 
  172.         move.l  d1,-(a7)        ; push the new float
  173. ;CODE
  174.    
  175.  
  176. :CODE  fDup
  177.         move.l  YERK[(fltNew)],d7  
  178.         jsr     0(a3,d7.l)        ; get new float in d1
  179.         move.l  (A7),d0         ; get float to dup
  180.         lea     2(a3,d0.l),a0
  181.         lea     2(a3,d1.l),a1
  182.         move.l  (a0)+,(a1)+
  183.         move.l  (a0)+,(a1)+
  184.         move.w  (a0)+,(a1)+
  185.         move.l  d1,-(a7)        ; push the new float
  186. ;CODE  
  187.  
  188. \ dup the top two floats on the stack
  189. :CODE  f2Dup
  190.         move.l  (A7),d0         ; get float to dup
  191.         move.l  YERK[(fltNew)],d7  
  192.         jsr     0(a3,d7.l)        ; get new float in d1
  193.         lea     2(a3,d0.l),a0
  194.         lea     2(a3,d1.l),a1
  195.         move.l  (a0)+,(a1)+
  196.         move.l  (a0)+,(a1)+
  197.         move.w  (a0)+,(a1)+
  198.         move.l  d1,d2           ; save the new float
  199.         move.l  4(a7),d0
  200.         move.l  YERK[(fltNew)],d7  
  201.         jsr     0(a3,d7.l)      ; get another float
  202.         lea     2(a3,d0.l),a0
  203.         lea     2(a3,d1.l),a1
  204.         move.l  (a0)+,(a1)+
  205.         move.l  (a0)+,(a1)+
  206.         move.w  (a0)+,(a1)+
  207.         move.l  d1,-(a7)    ; push bottom element
  208.         move.l  d2,-(a7)      
  209. ;CODE  
  210.  
  211. :CODE  fOver
  212.         move.l  4(A7),d0         ; get float to dup
  213.         move.l  YERK[(fltNew)],d7  
  214.         jsr     0(a3,d7.l)        ; get new float in d1
  215.         lea     2(a3,d0.l),a0
  216.         lea     2(a3,d1.l),a1
  217.         move.l  (a0)+,(a1)+
  218.         move.l  (a0)+,(a1)+
  219.         move.w  (a0)+,(a1)+
  220.         move.l  d1,-(a7)        ; push the new float
  221. ;CODE  
  222.  
  223. :CODE fDrop 
  224.         move.l  (A7)+,d0
  225.         move.l  YERK[(fltDisp)],d7  
  226.         jsr     0(a3,d7.l)        ; dispose of float in D0
  227. ;CODE
  228.  
  229. :CODE f2Drop 
  230.         move.l  (A7)+,d0
  231.         move.l  (a7)+,d1
  232.         move.l  YERK[(fltDisp2)],d7  
  233.         jsr     0(a3,d7.l)        ; dispose of float in D0
  234. ;CODE
  235.  
  236.    
  237. ( ops opCode -- )
  238. \ Call FP68K. Floating-point package.
  239. : fp68k     makeint call pack4   ;  
  240.  
  241. \ Call ELEMS68K.  Transcendentals package.
  242. : elems68k  makeint call pack5  ;
  243.